home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / kcl / kcl.lha / lsp / top.lsp < prev    next >
Lisp/Scheme  |  1987-06-04  |  22KB  |  616 lines
  1. ;; (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984.  All rights reserved.
  2. ;; Copying of this file is authorized to users who have executed the true and
  3. ;; proper "License Agreement for Kyoto Common LISP" with SIGLISP.
  4.  
  5. ;;;;  top.lsp
  6. ;;;;
  7. ;;;;  Top-level loop, break loop, and error handlers
  8. ;;;;
  9. ;;;;  Revised on July 11, by Carl Hoffman.
  10.  
  11.  
  12. (in-package 'lisp)
  13.  
  14. (export '(+ ++ +++ - * ** *** / // ///))
  15. (export '(break warn))
  16. (export '*break-on-warnings*)
  17. (export '*break-enable*)
  18.  
  19. (in-package 'system)
  20.  
  21. (export '*break-readtable*)
  22.  
  23. (export '(vs ihs-vs ihs-fun frs-vs frs-bds frs-ihs bds-var bds-val super-go))
  24.  
  25. (eval-when (compile) (proclaim '(optimize (safety 2) (space 3))))
  26.  
  27. (defvar +)
  28. (defvar ++)
  29. (defvar +++)
  30. (defvar -)
  31. (defvar *)
  32. (defvar **)
  33. (defvar ***)
  34. (defvar /)
  35. (defvar //)
  36. (defvar ///)
  37.  
  38. (defvar *eof* (cons nil nil))
  39. (defvar *lisp-initialized* nil)
  40.  
  41. (defvar *quit-tag* (cons nil nil))
  42. (defvar *quit-tags* nil)
  43. (defvar *break-level* '())
  44. (defvar *break-env* nil)
  45. (defvar *ihs-base* 1)
  46. (defvar *ihs-top* 1)
  47. (defvar *current-ihs* 1)
  48. (defvar *frs-base* 0)
  49. (defvar *frs-top* 0)
  50. (defvar *break-enable* t)
  51. (defvar *break-message* "")
  52.  
  53. (defvar *break-on-warnings* nil)
  54.  
  55. (defvar *break-readtable* nil)
  56. (defvar *break-hidden-functions* nil)
  57. (defvar *break-hidden-packages* (list (find-package 'system)))
  58.  
  59. (defun top-level ()
  60.   (let ((+ nil) (++ nil) (+++ nil)
  61.         (- nil)
  62.         (* nil) (** nil) (*** nil)
  63.         (/ nil) (// nil) (/// nil))
  64.     (setq *lisp-initialized* t)
  65.     (catch *quit-tag* (when (probe-file "init.lsp") (load "init.lsp")))
  66.     (loop
  67.       (setq +++ ++ ++ + + -)
  68.       (format t "~%~a>"
  69.               (if (eq *package* (find-package 'user)) ""
  70.                   (package-name *package*)))
  71.       (reset-stack-limits)
  72.       (when (catch *quit-tag*
  73.               (setq - (locally (declare (notinline read))
  74.                                (read *standard-input* nil *eof*)))
  75.               (when (eq - *eof*) (bye))
  76.               (let ((values (multiple-value-list
  77.                              (locally (declare (notinline eval)) (eval -)))))
  78.                 (setq /// // // / / values *** ** ** * * (car /))
  79.                 (fresh-line)
  80.                 (dolist (val /)
  81.                   (locally (declare (notinline prin1)) (prin1 val))
  82.                   (terpri))
  83.                 nil))
  84.         (terpri *error-output*)
  85.         (break-current)))))
  86.  
  87. (defun warn (format-string &rest args)
  88.   (let ((*print-level* 4)
  89.         (*print-length* 4)
  90.         (*print-case* :upcase))
  91.     (cond (*break-on-warnings*
  92.            (apply #'break format-string args))
  93.           (t (format *error-output* "~&Warning: ")
  94.              (let ((*indent-formatted-output* t))
  95.                (apply #'format *error-output* format-string args))
  96.              nil))))
  97.  
  98. (defun universal-error-handler
  99.   (error-name correctable function-name
  100.    continue-format-string error-format-string
  101.    &rest args &aux message)
  102.   (declare (ignore error-name))
  103.   (let ((*print-pretty* nil)
  104.         (*print-level* 4)
  105.         (*print-length* 4)
  106.         (*print-case* :upcase))
  107.        (terpri *error-output*)
  108.        (cond ((and correctable *break-enable*)
  109.               (format *error-output* "~&Correctable error: ")
  110.               (let ((*indent-formatted-output* t))
  111.                 (apply 'format *error-output* error-format-string args))
  112.               (terpri *error-output*)
  113.               (setq message (apply 'format nil error-format-string args))
  114.               (if function-name
  115.                   (format *error-output*
  116.                           "Signalled by ~:@(~S~).~%" function-name)
  117.                   (format *error-output*
  118.                           "Signalled by an anonymous function.~%"))
  119.               (format *error-output* "~&If continued: ")
  120.               (let ((*indent-formatted-output* t))
  121.                 (format *error-output* "~?~&" continue-format-string args))
  122.               )
  123.              (t
  124.               (format *error-output* "~&Error: ")
  125.               (let ((*indent-formatted-output* t))
  126.                 (apply 'format *error-output* error-format-string args))
  127.               (terpri *error-output*)
  128.               (setq message (apply 'format nil error-format-string args))
  129.               (if function-name
  130.                   (format *error-output*
  131.                           "Error signalled by ~:@(~S~).~%" function-name)
  132.                   (format *error-output*
  133.                           "Error signalled by an anonymous function.~%")))))
  134.   (break-level message)
  135.   (unless correctable (throw *quit-tag* *quit-tag*)))
  136.  
  137. (defun break (&optional format-string &rest args &aux message)
  138.   (let ((*print-pretty* nil)
  139.         (*print-level* 4)
  140.         (*print-length* 4)
  141.         (*print-case* :upcase))
  142.        (terpri *error-output*)
  143.     (cond (format-string
  144.            (format *error-output* "~&Break: ")
  145.            (let ((*indent-formatted-output* t))
  146.              (apply 'format *error-output* format-string args))
  147.            (terpri *error-output*)
  148.            (setq message (apply 'format nil format-string args)))
  149.           (t (format *error-output* "~&Break.~%")
  150.              (setq message ""))))
  151.   (let ((*break-enable* t)) (break-level message))
  152.   nil)
  153.  
  154. (defun terminal-interrupt (correctablep)
  155.   (let ((*break-enable* t))
  156.     (if correctablep
  157.         (cerror "Console interrupt." "Continues execution.")
  158.         (error "Console interrupt -- cannot continue."))))
  159.  
  160. (defun break-level (*break-message*)
  161.   (let* ((*quit-tags* (cons (cons *break-level* *quit-tag*) *quit-tags*))
  162.          (*quit-tag* (cons nil nil))
  163.          (*break-level* (cons t *break-level*))
  164.          (*ihs-base* (1+ *ihs-top*))
  165.          (*ihs-top* (1- (ihs-top)))
  166.          (*current-ihs* *ihs-top*)
  167.          (*frs-base* (or (sch-frs-base *frs-top* *ihs-base*) (1+ (frs-top))))
  168.          (*frs-top* (frs-top))
  169.          (*break-env* nil)
  170.          (be *break-enable*)
  171.          (*break-enable* nil)
  172.          ;(*standard-input* *terminal-io*)
  173.          (*readtable* (or *break-readtable* *readtable*))
  174.          (*read-suppress* nil)
  175.          (+ +) (++ ++) (+++ +++)
  176.          (- -)
  177.          (* *) (** **) (*** ***)
  178.          (/ /) (// //) (/// ///)
  179.          )
  180.     (unless be
  181.       (simple-backtrace)
  182.       (break-quit (length (cdr *break-level*))))
  183.     (terpri *error-output*)
  184.     (set-current)
  185.     (loop 
  186.       (setq +++ ++ ++ + + -)
  187.       (format *debug-io* "~%~a>~{~*>~}"
  188.               (if (eq *package* (find-package 'user)) ""
  189.                   (package-name *package*))
  190.               *break-level*)
  191.       (when
  192.         (catch *quit-tag*
  193.           (setq - (locally (declare (notinline read))
  194.                     (read *debug-io* nil *eof*)))
  195.           (when (eq - *eof*) (bye))
  196.           (let ((values
  197.                   (multiple-value-list
  198.                     (locally (declare (notinline break-call evalhook))
  199.                       (cond ((keywordp -)
  200.                              (when (or (eq - :r) (eq - :resume)) (return))
  201.                              (break-call - nil))
  202.                             ((and (consp -) (keywordp (car -)))
  203.                              (when (or (eq (car -) :r) (eq (car -) :resume))
  204.                                (return))
  205.                              (break-call (car -) (cdr -)))
  206.                             (t (evalhook - nil nil *break-env*)))))))
  207.             (setq /// // // / / values *** ** ** * * (car /))
  208.             (fresh-line *debug-io*)
  209.             (dolist (val /)
  210.               (locally (declare (notinline prin1)) (prin1 val *debug-io*))
  211.               (terpri *debug-io*)))
  212.           nil)
  213.         (terpri *debug-io*)
  214.         (break-current)))))
  215.  
  216. (defun break-call (key args &aux (fun (get key 'break-command)))
  217.   (if fun
  218.       (evalhook (cons fun args) nil nil *break-env*)
  219.       (format *debug-io* "~&~S is undefined break command.~%" key)))
  220.  
  221. (defun break-quit (&optional (level 0)
  222.                    &aux (current-level (length *break-level*)))
  223.   (when (and (>= level 0) (< level current-level))
  224.     (let ((x (nth (- current-level level 1) *quit-tags*)))
  225.       (throw (cdr x) (cdr x))))
  226.   (break-current))
  227.  
  228. (defun break-previous (&optional (offset 1))
  229.   (do ((i (1- *current-ihs*) (1- i)))
  230.       ((or (< i *ihs-base*) (<= offset 0))
  231.        (set-env)
  232.        (break-current))
  233.     (when (ihs-visible i)
  234.       (setq *current-ihs* i)
  235.       (setq offset (1- offset)))))
  236.  
  237. (defun set-current ()
  238.   (do ((i *current-ihs* (1- i)))
  239.       ((or (ihs-visible i) (<= i *ihs-base*))
  240.        (setq *current-ihs* i)
  241.        (set-env)
  242.        (format *debug-io* "Broken at ~:@(~S~).~:[  Type :H for Help.~;~]"
  243.                (ihs-fname *current-ihs*)
  244.                (cdr *break-level*)))))
  245.  
  246. (defun break-next (&optional (offset 1))
  247.   (do ((i *current-ihs* (1+ i)))
  248.       ((or (> i *ihs-top*) (< offset 0))
  249.        (set-env)
  250.        (break-current))
  251.     (when (ihs-visible i)
  252.       (setq *current-ihs* i)
  253.       (setq offset (1- offset)))))
  254.  
  255. (defun break-go (ihs-index)
  256.   (setq *current-ihs* (min (max ihs-index *ihs-base*) *ihs-top*))
  257.   (if (ihs-visible *current-ihs*)
  258.       (progn (set-env) (break-current))
  259.       (break-previous)))
  260.  
  261. (defun break-message ()
  262.   (princ *break-message* *debug-io*)
  263.   (terpri *debug-io*)
  264.   (values))
  265.  
  266. (defun break-variables ()
  267.   (apply #'format *debug-io* "Local variables: ~#[none~;~S~;~S and ~S~
  268.          ~:;~@{~#[~;and ~]~S~^, ~}~]."
  269.          (mapcar #'car (car *break-env*))))
  270.  
  271. (defun break-functions ()
  272.   (apply #'format *debug-io* "Local functions: ~#[none~;~S~;~S and ~S~
  273.          ~:;~@{~#[~;and ~]~S~^, ~}~]."
  274.          (mapcar #'car (cadr *break-env*))))
  275.  
  276. (defun break-blocks ()
  277.   (apply #'format *debug-io* "Block names: ~#[none~;~S~;~S and ~S~
  278.          ~:;~@{~#[~;and ~]~S~^, ~}~]."
  279.          (mapcan #'(lambda (x) (when (eq (cadr x) 'block) (list (car x))))
  280.                  (caddr *break-env*))))
  281.  
  282. (defun break-tags ()
  283.   (apply #'format *debug-io* "Tags: ~#[none~;~S~;~S and ~S~
  284.          ~:;~@{~#[~;and ~]~S~^, ~}~]."
  285.          (mapcan #'(lambda (x) (when (eq (cadr x) 'tag) (list (car x))))
  286.                  (caddr *break-env*))))
  287.  
  288. (defun break-vs (&optional (x (ihs-vs *ihs-base*)) (y (ihs-vs *ihs-top*)))
  289.   (setq x (max x (ihs-vs *ihs-base*)))
  290.   (setq y (min y (1- (ihs-vs (1+ *ihs-top*)))))
  291.   (do ((ii *ihs-base* (1+ ii)))
  292.       ((or (>= ii *ihs-top*) (>= (ihs-vs ii) x))
  293.        (do ((vi x (1+ vi)))
  294.            ((> vi y) (values))
  295.          (do ()
  296.              ((> (ihs-vs ii) vi))
  297.            (when (ihs-visible ii) (print-ihs ii))
  298.            (incf ii))
  299.          (format *debug-io* "~&VS[~d]: ~s" vi (vs vi))))))
  300.  
  301. (defun break-local (&optional (n 0) &aux (x (+ (ihs-vs *current-ihs*) n)))
  302.   (break-vs x x))
  303.  
  304. (defun break-bds (vars &aux (fi *frs-base*))
  305.   (unless (consp vars) (setq vars (list vars)))
  306.   (do ((bi (1+ (frs-bds (1- *frs-base*))) (1+ bi))
  307.        (last (frs-bds (1+ *frs-top*))))
  308.       ((> bi last) (values))
  309.     (when (member (bds-var bi) vars)
  310.       (do ()
  311.           ((or (> fi *frs-top*) (> (frs-bds fi) bi)))
  312.         (print-frs fi)
  313.         (incf fi))
  314.       (format *debug-io* "~&BDS[~d]: ~s = ~s"
  315.               bi (bds-var bi) (bds-val bi)))))
  316.  
  317. (defun simple-backtrace ()
  318.   (princ "Backtrace: " *debug-io*)
  319.   (do* ((i *ihs-base* (1+ i))
  320.         (b nil t))
  321.        ((> i *ihs-top*) (terpri *debug-io*) (values))
  322.     (when (ihs-visible i)
  323.       (when b (princ " > " *debug-io*))
  324.       (write (ihs-fname i) :stream *debug-io* :escape t
  325.              :case (if (= i *current-ihs*) :upcase :downcase)))))
  326.  
  327. (defun backtrace (&optional (from *ihs-base*) (to *ihs-top*))
  328.   (setq from (max from *ihs-base*))
  329.   (setq to (min to *ihs-top*))
  330.   (do* ((i from (1+ i))
  331.         (j (or (sch-frs-base *frs-base* from) (1+ *frs-top*))))
  332.        ((> i to) (values))
  333.     (when (ihs-visible i) (print-ihs i))
  334.     (do () ((or (> j *frs-top*) (> (frs-ihs j) i)))
  335.       (print-frs j)
  336.       (incf j))))
  337.  
  338. (defun print-ihs (i &aux (*print-level* 2) (*print-length* 4))
  339.   (format t "~&~:[  ~;@ ~]IHS[~d]: ~s ---> VS[~d]"
  340.           (= i *current-ihs*)
  341.           i
  342.           (let ((fun (ihs-fun i)))
  343.             (cond ((or (symbolp fun) (compiled-function-p fun)) fun)
  344.                   ((consp fun)
  345.                    (case (car fun)
  346.                      (lambda fun)
  347.                      (lambda-block (cdr fun))
  348.                      (lambda-closure (cons 'lambda (cddddr fun)))
  349.                      (lambda-block-closure (cddddr fun))
  350.                      (t '(:zombi))))
  351.                   (t :zombi)))
  352.           (ihs-vs i)))
  353.  
  354. (defun print-frs (i)
  355.   (format *debug-io* "~&    FRS[~d]: ~s ---> IHS[~d],VS[~d],BDS[~d]"
  356.           i (frs-kind i) (frs-ihs i) (frs-vs i) (frs-bds i)))
  357.  
  358. (defun frs-kind (i &aux x)
  359.   (case (frs-class i)
  360.     (:catch
  361.      (if (spicep (frs-tag i))
  362.          (or (and (setq x (member (frs-tag i) (vs (+ (frs-vs i) 2))
  363.                                   :key #'caddr :test #'eq))
  364.                   (if (eq (cadar x) 'block)
  365.                       `(block ,(caar x) ***)
  366.                       `(tagbody ,@(reverse (mapcar #'car
  367.                                              (remove (frs-tag i) x
  368.                                                      :test-not #'eq
  369.                                                      :key #'caddr)))
  370.                                 ***)))
  371.              `(block/tagbody ,(frs-tag i)))
  372.          `(catch ',(frs-tag i) ***)))
  373.     (:protect '(unwind-protect ***))
  374.     (t `(system-internal-catcher ,(frs-tag i)))))
  375.  
  376. (defun break-current ()
  377.   (if *break-level*
  378.       (format *debug-io* "Broken at ~:@(~S~)." (ihs-fname *current-ihs*))
  379.       (format *debug-io* "~&Top level."))
  380.   (values))
  381.  
  382. (defun break-hide (fname)
  383.   (unless (member fname *break-hidden-functions*)
  384.     (setq *break-hidden-functions*
  385.           (cons fname *break-hidden-functions*))
  386.     (unless (ihs-visible *current-ihs*)
  387.       (break-previous)))
  388.   (values))
  389.  
  390. (defun break-unhide (fname)
  391.   (setq *break-hidden-functions*
  392.         (list-delq fname *break-hidden-functions*))
  393.   (values))
  394.  
  395. (defun break-unhide-package (package)
  396.   (setq package (find-package package))
  397.   (setq *break-hidden-packages*
  398.         (list-delq package *break-hidden-packages*))
  399.   (values))
  400.  
  401. (defun break-unhide-all ()
  402.   (setq *break-hidden-functions* nil)
  403.   (setq *break-hidden-packages* nil)
  404.   (values))
  405.  
  406. (defun break-hide-package (package)
  407.   (setq package (find-package package))
  408.   (unless (member package *break-hidden-packages*)
  409.     (setq *break-hidden-packages*
  410.           (cons package *break-hidden-packages*))
  411.     (unless (ihs-visible *current-ihs*)
  412.       (break-previous)))
  413.   (values))
  414.  
  415. (defun ihs-visible (i)
  416.   (let ((fname (ihs-fname i)))
  417.     (or (eq fname 'eval)
  418.         (eq fname 'evalhook)
  419.         (and (not (member (symbol-package fname) *break-hidden-packages*))
  420.              (not (null fname))
  421.              (not (member fname *break-hidden-functions*))))))
  422.  
  423. (defun ihs-fname (ihs-index)
  424.   (let ((fun (ihs-fun ihs-index)))
  425.     (cond ((symbolp fun) fun)
  426.           ((consp fun)
  427.            (case (car fun)
  428.              (lambda 'lambda)
  429.              (lambda-block (cadr fun))
  430.              (lambda-block-closure (nth 4 fun))
  431.              (lambda-closure 'lambda-closure)
  432.              (t :zombi)))
  433.           ((compiled-function-p fun)
  434.            (compiled-function-name fun))
  435.           (t :zombi))))
  436.  
  437. (defun set-env ()
  438.   (setq *break-env*
  439.         (if (ihs-compiled-p *current-ihs*)
  440.             nil
  441.             (let ((i (ihs-vs *current-ihs*)))
  442.               (list (vs i) (vs (1+ i)) (vs (+ i 2)))))))
  443.  
  444. (defun ihs-compiled-p (ihs-index)
  445.   (let ((fun (ihs-fun ihs-index)))
  446.        (or (and (symbolp fun) (not (special-form-p fun)))
  447.            (compiled-function-p fun))))
  448.  
  449. (defun list-delq (x l)
  450.   (cond ((null l) nil)
  451.         ((eq x (car l)) (cdr l))
  452.         (t (rplacd l (list-delq x (cdr l))))))
  453.  
  454. (defun super-go (i tag &aux x)
  455.   (when (and (>= i *frs-base*) (<= i *frs-top*) (spicep (frs-tag i)))
  456.     (if (setq x (member (frs-tag i) (vs (+ (frs-vs i) 2))
  457.                         :key #'caddr :test #'eq))
  458.         ; Interpreted TAGBODY.
  459.         (when (and (eq (cadar x) 'tag)
  460.                    (member tag (mapcar #'car (remove (frs-tag i) x
  461.                                                      :test-not #'eq
  462.                                                      :key #'caddr))))
  463.           (internal-super-go (frs-tag i) tag t))
  464.         ; Maybe, compiled cross-closure TAGBODY.
  465.         ; But, it may also be compiled cross-closure BLOCK, in which case
  466.         ; SUPER-GO just RETURN-FROMs with zero values.
  467.         (internal-super-go (frs-tag i) tag nil)))
  468.   (format *debug-io* "~s is invalid tagbody identification for ~s." i tag))
  469.  
  470. (defun break-backward-search-stack (sym &aux string)
  471.   (setq string (string sym))
  472.   (do* ((ihs (1- *current-ihs*) (1- ihs))
  473.         (fname (ihs-fname ihs) (ihs-fname ihs)))
  474.       ((< ihs *ihs-base*)
  475.        (format *debug-io* "Search for ~a failed.~%" string))
  476.     (when (and (ihs-visible ihs)
  477.                (search string (symbol-name fname) :test #'char-equal))
  478.       (break-go ihs)
  479.       (return))))
  480.  
  481. (defun break-forward-search-stack (sym &aux string)
  482.   (setq string (string sym))
  483.   (do* ((ihs (1+ *current-ihs*) (1+ ihs))
  484.         (fname (ihs-fname ihs) (ihs-fname ihs)))
  485.       ((> ihs *ihs-top*)
  486.        (format *debug-io* "Search for ~a failed.~%" string))
  487.     (when (and (ihs-visible ihs)
  488.                (search string (symbol-name fname) :test #'char-equal))
  489.       (break-go ihs)
  490.       (return))))
  491.  
  492. (defun break-variables-values ()
  493.   (dolist (x (car *break-env*))
  494.     (format *debug-io* "~S: ~S~%" (first x) (second x))))
  495.  
  496. (putprop :b 'simple-backtrace 'break-command)
  497. (putprop :backtrace 'simple-backtrace 'break-command)
  498. (putprop :bds 'break-bds 'break-command)
  499. (putprop :blocks 'break-blocks 'break-command)
  500. (putprop :bs 'break-backward-search-stack 'break-command)
  501. (putprop :c 'break-current 'break-command)
  502. (putprop :current 'break-current 'break-command)
  503. (putprop :fs 'break-forward-search-stack 'break-command)
  504. (putprop :functions 'break-functions 'break-command)
  505. (putprop :go 'break-go 'break-command)
  506. (putprop :h 'break-help 'break-command)
  507. (putprop :help 'break-help 'break-command)
  508. (putprop :hd 'break-hide 'break-command)
  509. (putprop :hdp 'break-hide-package 'break-command)
  510. (putprop :hh 'break-help-help 'break-command)
  511. (putprop :hide 'break-hide 'break-command)
  512. (putprop :hide-package 'break-hide-package 'break-command)
  513. (putprop :hs 'break-help-stack-funs 'break-command)
  514. (putprop :ihs 'backtrace 'break-command)
  515. (putprop :l 'break-local 'break-command)
  516. (putprop :lb 'break-blocks 'break-command)
  517. (putprop :lf 'break-functions 'break-command)
  518. (putprop :local 'break-local 'break-command)
  519. (putprop :lt 'break-tags 'break-command)
  520. (putprop :lv 'break-variables 'break-command)
  521. (putprop :m 'break-message 'break-command)
  522. (putprop :n 'break-next 'break-command)
  523. (putprop :next 'break-next 'break-command)
  524. (putprop :p 'break-previous 'break-command)
  525. (putprop :previous 'break-previous 'break-command)
  526. (putprop :q 'break-quit 'break-command)
  527. (putprop :quit 'break-quit 'break-command)
  528. (putprop :s 'break-backward-search-stack 'break-command)
  529. (putprop :tags 'break-tags 'break-command)
  530. (putprop :uh 'break-unhide 'break-command)
  531. (putprop :uha 'break-unhide-all 'break-command)
  532. (putprop :uhp 'break-unhide-package 'break-command)
  533. (putprop :unhide 'break-unhide 'break-command)
  534. (putprop :unhide-package 'break-unhide-package 'break-command)
  535. (putprop :v 'break-variables 'break-command)
  536. (putprop :variable 'break-variables 'break-command)
  537. (putprop :vs 'break-vs 'break-command)
  538. (putprop :vv 'break-variables-values 'break-command)
  539.  
  540. (defun break-help ()
  541.   (format *debug-io* "
  542. Break-loop Command Summary:
  543.  
  544. :p (Previous)        :n (Next)        :go (GO)    
  545. :m (Message)        :c (Current)
  546. :h (Help)        :hh (Help Help)        :hs (Help Stack functions)
  547. :q (Quit)        :r (Resume or Return)
  548. :b (Backtrace)        :l (Local value)
  549. :vs (Value Stack)    :bds (BinD Stack)    :ihs (Invocation Hist. Stack)
  550. :lv (Local Variables)    :v (= :lv)        :lf (Local Functions)
  551. :lb (Blocks)        :lt (Tags)
  552. :hd (HiDE)        :hdp (HiDe Packages)
  553. :uha (UnHide All)     :uh (UnHide)        :uhp (UnHide Packages)
  554. :bs (Backward Search)    :s (= :bs)        :fs (Forward Search)
  555. :vv (Variables Values)
  556.  
  557. Type :HH for more details.
  558. "))
  559.  
  560. (defun break-help-help ()
  561.   (format *debug-io* "
  562. Break-loop Commands:
  563.  
  564. :p [i]        Go to the i-th previous function.  i defaults to 1.
  565. :n [i]        Go to the i-the next function.  i defaults to 1.
  566. :go i        Go to the function at IHS[i].
  567. :m        Print the error message.
  568. :c        Show the current function.
  569. :h        Show the break command summary.
  570. :hh        Show this message.
  571. :hs        Show stack-accessing functions.
  572. :q [i]        Return to the level i break-level (or top-level if i = 0).
  573.         i defaults to 0.
  574. :r        Return to the caller of break-level.
  575. :b        Print simple backtrace.
  576. :l [i]        Print i-th local value.
  577. :vs [from [to]]    Show values in the stack between VS[from] to VS[to].
  578.         'from' defaults to 0 and 'to' defaults to positive infinity.
  579. :bds var-list    Show previous bindings of the variables.  'var-list' may be
  580.         a symbol or a list of symbols.
  581. :ihs [from [to]] Print backtrace between IHS[from] to IHS[to].
  582.         'from' defaults to 0 and 'to' defaults to positive infinity.
  583. :lv        Show local variables.
  584. :lf        Show local functions.
  585. :lb        Show block names.
  586. :lt        Show tags.
  587. :hd symbol    Hide the function named by the specified symbol.
  588. :hdp package    Hide functions in the specified package.
  589. :uha        Unhide all functions.
  590. :uh symbol    Unhide the function named by the specified symbol.
  591. :uhp package    Unhide functions in the specified package.
  592. "))
  593.  
  594. (defun break-help-stack-funs ()
  595.   (format *debug-io* "
  596. Use the following functions to directly access KCL stacks.
  597.  
  598. (SI:VS i)    Returns the i-th entity in VS.
  599. (SI:IHS-VS i)    Returns the VS index of the i-th entity in IHS.
  600. (SI:IHS-FUN i)    Returns the function of the i-th entity in IHS.
  601. (SI:FRS-VS i)    Returns the VS index of the i-th entity in FRS.
  602. (SI:FRS-BDS i)    Returns the BDS index of the i-th entity in FRS.
  603. (SI:FRS-IHS i)    Returns the IHS index of the i-th entity in FRS.
  604. (SI:BDS-VAR i)    Returns the symbol of the i-th entity in BDS.
  605. (SI:BDS-VAL i)    Returns the value of the i-th entity in BDS.
  606.  
  607. (SI:SUPER-GO i tag)
  608.     Jumps to the specified tag established by the TAGBODY frame at
  609.     FRS[i].  Both arguments are evaluated.  If FRS[i] happens to be
  610.     a non-TAGBODY frame, then (THROW (SI:IHS-TAG i) (VALUES)) is
  611.     performed.
  612.  
  613. Note that these functions are named by external symbols in the SYSTEM
  614. package.  For the KCL stacks, refer to Appendix B of the KCL Report.
  615. "))
  616.